home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / Algorithms Folder / upload / prolog.QBAS < prev    next >
Encoding:
Text File  |  1994-05-18  |  5.7 KB  |  137 lines  |  [TEXT/MSBB]
  1. 'copyright 1994 by Stephen Boerner, eye systems- 
  2. 'CIS-74203,2217   AOL-ISISINC  BMUG, INTERNET EYESYS@CRL.COM
  3. 'MAY NOT BE USED FOR COMMERCIAL GAIN
  4.  
  5. REM    a PROLOG COMPILER - navigate to program of prodatall, turn trace on with space,return
  6. REM   and enter interactive  prolog interpreter
  7. REM  exit by selecting cancel from files$ dialog 
  8. REM lowercase only
  9.  
  10. DEFINT a-z:WIDTH 65:P1=100:p2=90:p3=30:tr$(0)="off":tr$(1)="on":trace=0
  11. REM p1 IS #vars p2 IS #stmts p3 IS #(((s
  12. DIM SHARED v$(100),s(2000),sn(100),ln(100),q(90),K(90),kb(100),z(30),zx(30),w(100),s1(100),s2(100)
  13. BEG:sn(1)=2:N=0:nv=4:ns=2:m=-1:FOR kk=1 TO nv:kb(kk)=0:NEXT:CALL pk0(N,ns,nv)
  14. goal:LINE INPUT " >";a$:IF a$="" THEN BEG
  15. IF LEFT$(a$,1)=" " THEN trace=1-trace:PRINT "trace ";tr$(trace);:GOTO goal
  16. N=N+1:m=N:CALL pack(a$,N,ns,nv):s(ns)=0
  17. BK0:K(N)=kb(s(sn(N)))
  18. BK:I=sn(N):si=s(I):in=ln(N):f=0:IF si=4 THEN N=nn:GOTO BT
  19. FOR K=K(N) TO m:j=sn(K):IF si<>s(j) OR K=0 THEN  BT
  20. jn=ln(K):nz=0:CALL unify((I),(in),(j),(jn),nq,f,N,nv,nz):IF f=1 THEN AN
  21. BN:NEXT K:GOTO BT
  22. AN:ns0=ns:K(N)=K+1:IF trace=1 THEN CALL prnt(nq,N,K)
  23. IF si=3 THEN CALL prt2(I,in)
  24. CALL copy(jn,ns,nq,N,nv,nz):CALL copy(in,ns,nq,N,nv,nz)
  25. N=N+1:sn(N)=ns0:CALL SKIP(ns0,lnn):ln(N)=lnn:s(ns)=0:ns=ns+1
  26. IF K(K)=-1 THEN nn=N-1:IF trace=1 THEN PRINT"CUT";
  27. IF ns0<ns-1 THEN BK0
  28. BT:IF trace=1 THEN IF f=0 THEN PRINT "FAIL"; ELSE PRINT "SUC"; 
  29. IF trace=0 THEN  IF f=1 THEN PRINT TAB(57);"(yes)"
  30. N=N-1:ns=sn(N+1):IF N<m THEN GOTO goal ELSE GOTO BK
  31. SUB unify(I,in,j,jn,nq,f,N,nv,nz) STATIC
  32. nq=0:n2=0:IF fir=0 THEN fir=1:z0=0:z1=1
  33. UN:IF z0=1 THEN GOSUB SW
  34. IF I=in AND j=jn AND n2=0 THEN f=1:EXIT SUB
  35. IF  I=in AND n2>0 THEN n2=n2-2:I=w(n2):in=w(n2+1):GOTO UN
  36. IF j=jn AND n2>0 THEN n2=n2-2:j=w(n2):jn=w(n2+1):GOTO UN
  37. V2:IF s(I)>=0 THEN IF s(j)<0 THEN GOSUB SW ELSE U2
  38. sk=s(I):GOSUB zz:FOR kk=0 TO nq-1 STEP 3:IF sk<>s(q(kk+z0)) THEN NK ELSE w(n2)=I+1
  39. w(n2+1)=in:I=q(kk+z1):GOSUB SKI:n2=n2+2:IF n2>99 THEN PRINT "occur check":EXIT SUB ELSE UN
  40. NK:NEXT kk:q(nq+z0)=I:q(nq+z1)=j:I=I+1:GOSUB SKJ:q(nq+2)=j:nq=nq+3:GOTO UN
  41. U2:IF s(I)=s(j) THEN I=I+1:j=j+1:GOTO UN ELSE EXIT SUB
  42. zz:FOR kz=1 TO nz:IF z(kz)<>sk THEN NEXT kz:nz=nz+1:z(nz)=sk:zx(nz)=z0:RETURN
  43. IF zx(kz)=z0 THEN RETURN ELSE t$="_"+v$(-sk)+HEX$(N):FOR jk=0 TO nv
  44. IF v$(jk)=t$ THEN sk=-jk ELSE NEXT jk:nv=nv+1:v$(nv)=t$:sk=-nv:RETURN
  45. RETURN
  46. SW:SWAP I,j:SWAP in,jn:SWAP z0,z1:RETURN
  47. SKI:in=I+1:IF s(in)<>1 THEN RETURN ELSE l=0
  48. SKI2:IF s(in)=2 THEN l=l+1 ELSE IF s(in)=1 THEN l=l-1
  49. in=in+1:IF l=0 THEN RETURN ELSE SKI2
  50. SKJ:j=j+1:IF s(j)<>1 THEN RETURN ELSE l=0
  51. SKJ2:IF s(j)=2 THEN l=l+1 ELSE IF s(j)=1 THEN l=l-1
  52. j=j+1:IF l=0 THEN RETURN ELSE SKJ2
  53. END SUB
  54. SUB SKIP(hh,H) STATIC:H=hh+1
  55. IF s(H)<>1 THEN EXIT SUB ELSE l=0
  56. SK2:IF s(H)=2 THEN l=l+1 ELSE IF s(H)=1 THEN l=l-1
  57. H=H+1:IF l=0 THEN EXIT SUB ELSE SK2
  58. END SUB
  59. SUB copy(kn,ns,nq,N,nv,nz) STATIC
  60. IF fir=0 THEN fir=1:z=0
  61. z=1-z:nw=0:kk=kn:WHILE s(kk)<>0:sk=s(kk)
  62. IF sk>0 THEN s(ns)=sk:ns=ns+1 ELSE GOSUB t
  63. kk=kk+1:WEND:EXIT SUB
  64. t:FOR kl=0 TO nq-1 STEP 3:IF (sk<>s(q(kl+z))) THEN tx
  65. IF z=1 AND s(q(kl))<0 THEN tx
  66. qk=q(kl+2):km=q(kl+1-z):WHILE km<qk:w(nw)=qk:w(nw+1)=km:nw=nw+2
  67. z=1-z:sk=s(km):IF sk>0 THEN s(ns)=sk:ns=ns+1 ELSE GOSUB t
  68. z=1-z:nw=nw-2:qk=w(nw):km=w(nw+1)+1:WEND:RETURN
  69. tx:NEXT kl:GOSUB zzz:s(ns)=sk:ns=ns+1:RETURN
  70. zzz:FOR kz=1 TO nz:IF z(kz)<>sk THEN NEXT kz:nz=nz+1:z(nz)=sk:zx(nz)=z:RETURN
  71. IF zx(kz)=z THEN RETURN ELSE t$="_"+v$(-sk)+HEX$(N):FOR j=0 TO nv
  72. IF v$(j)=t$ THEN sk=-j ELSE NEXT j:nv=nv+1:v$(nv)=t$:sk=-nv
  73. RETURN:END SUB
  74. SUB prt2(b,e) STATIC:PRINT "   ";
  75. FOR kk=b+2 TO e-2:PRINT v$(ABS(s(kk)));
  76. NEXT kk:EXIT SUB:END SUB
  77. SUB prnt(nq,N,K) STATIC
  78. PRINT TAB(2);N;:CALL prt(sn(N))
  79. PRINT TAB(20);:FOR kk=0 TO nq-1 STEP 3:sq=s(q(kk))
  80. IF sq<=0 THEN PRINT v$(ABS(sq));"=";:CALL prt3(q(kk+1),q(kk+2)-1):PRINT "|";
  81. IF sq>0 THEN CALL prt3(q(kk),q(kk+2)-1):PRINT "=";v$(ABS(s(q(kk+1))));"|";
  82. NEXT kk:PRINT TAB(32);K;TAB(36);:CALL prt(sn(K)):EXIT SUB
  83. END SUB
  84. SUB prt3(b,e) STATIC:FOR kk=b TO e:PRINT v$(ABS(s(kk)));
  85. IF ABS(s(kk+1))>2 AND s(kk)<>1 AND kk<>e THEN PRINT ",";
  86. NEXT kk:EXIT SUB
  87. END SUB
  88. SUB prt(b) STATIC:kk=b:WHILE s(kk)<>0:PRINT v$(ABS(s(kk)));
  89. IF ABS(s(kk+1))>2 AND s(kk)<>1 AND s(kk+1)<>0 THEN PRINT ",";
  90. kk=kk+1:WEND:EXIT SUB
  91. END SUB
  92. SUB pk0(N,ns,nv) STATIC:P1=100:p=1
  93. CLS:f$=FILES$(1,"TEXT"):OPEN f$ FOR INPUT AS #1:LOCATE 3,1
  94. bb:WHILE NOT EOF(1):LINE INPUT #1,a$:IF a$<>"" THEN v$(P1-p)=a$:p=p+1
  95. WEND:CLOSE#1:RESTORE 1000
  96. READ a$:WHILE a$<>"":v$(P1-p)=a$:p=p+1:READ a$:WEND
  97. FOR k1=1 TO p-1:w$=v$(P1-k1):GOSUB ins:x$=s$
  98. WHILE x$=s$:k1=k1+1:w$=v$(P1-k1):GOSUB ins:WEND:k1=k1-1
  99. FOR k2=k1+1 TO p-1:w$=v$(P1-k2):GOSUB ins
  100. IF s$=x$ THEN GOSUB swt
  101. NEXT k2,k1
  102. FOR kk=1 TO p-1:a$=v$(P1-kk):PRINT TAB(2);N+1;a$
  103. N=N+1:CALL pack(a$,N,ns,nv):NEXT kk:EXIT SUB
  104. ins:j=LEN(w$):j1=INSTR(w$,"|"):IF j1>1 THEN j=j1-1
  105. j1=INSTR(w$,"("):IF j1>1 AND j1<j THEN j=j1-1
  106. s$=LEFT$(w$,j):RETURN
  107. swt:FOR k3=k2 TO k1+2 STEP -1
  108. v$(P1-k3)=v$(P1-k3+1):NEXT k3:v$(P1-k1-1)=w$:k1=k1+1:RETURN
  109. 1000 DATA "eq(X,X)"
  110. DATA "list(A)"
  111. DATA "?(A,B)"
  112. DATA "not(X)|X,!,fail"
  113. DATA "not(X)"
  114. DATA ""
  115. END SUB
  116. REM takes an array a(N) and sorts it
  117. SUB pack(a$,N,ns,nv) STATIC:P1=100:l=0:ln(N)=0:K(N)=0:fv=0:ns0=ns
  118. IF fir=0 THEN fir=1:v$(0)="@":v$(1)="(":v$(2)=")":v$(3)="?":v$(4)="!":
  119. a$=a$+"|)))":la=LEN(a$):FOR I=1 TO la:c$=MID$(a$,I,1):IF c$="!" THEN K(N)=-1
  120. IF c$="(" OR c$=")" OR c$="," OR c$="|" OR c$=" " THEN pk2
  121. t$=t$+c$:GOTO n2
  122. pk2:IF t$<>"" THEN z$=LEFT$(t$,1):tz=1
  123. IF t$<>"" AND z$>="A" AND z$<="Z" AND c$<>"(" THEN tz=-1
  124. IF t$<>"" THEN GOSUB a
  125. IF c$="(" THEN s1(l)=K:l=l+1:s(ns)=1:ns=ns+1
  126. IF c$=")" THEN l=l-1:IF l<0 THEN n3 ELSE s(ns)=2:ns=ns+1
  127. IF c$="|" AND (I<>la-3 OR ln(N)=0) THEN ln(N)=ns
  128. n2:NEXT I
  129. a:FOR j=0 TO nv:IF v$(j)=t$ THEN K=j ELSE NEXT j:nv=nv+1:v$(nv)=t$:K=nv
  130. IF kb(K)=0 AND ns=ns0 THEN kb(K)=N
  131. s(ns)=K*tz:ns=ns+1:t$="":s2(l)=s2(l)+1:RETURN
  132. n3:s(ns)=0:ns=ns+1:sn(N+1)=ns
  133. IF I<>la-2 THEN PRINT "unbalanced ";a$
  134. EXIT SUB:END SUB
  135.  
  136.  
  137.